home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / prolog / sbprolog / amiga / modlibsr.zoo / $setof.P < prev    next >
Text File  |  1988-09-15  |  20KB  |  563 lines
  1. %   File   : SETOF.PL
  2. %   Author : R.A.O'Keefe
  3. %   Updated: 17 November 1983
  4. %   Purpose: define set_of/3, bag_of/3, findall/3, and findall/4
  5. %   Needs  : Not.Pl
  6. %
  7. %   Modified for SB-Prolog by Saumya K. Debray, May 1988.
  8. %   Some of the code for the SB-Prolog version, specifically
  9. %   the version of $findall/3 using buff_code, was written by
  10. %   David S. Warren (in 1986?).
  11.  
  12. /*  This file defines two predicates which act like setof/3 and bagof/3.
  13.     I have seen the code for these routines in Dec-10 and in C-Prolog,
  14.     but I no longer recall it, and this code was independently derived
  15.     in 1982 by me and me alone.
  16.  
  17.     Most of the complication comes from trying to cope with free variables
  18.     in the Filter; these definitions actually enumerate all the solutions,
  19.     then group together those with the same bindings for the free variables.
  20.     There must be a better way of doing this.  I do not claim any virtue for
  21.     this code other than the virtue of working.  In fact there is a subtle
  22.     bug: if setof/bagof occurs as a data structure in the Generator it will
  23.     be mistaken for a call, and free variables treated wrongly.  Given the
  24.     current nature of Prolog, there is no way of telling a call from a data
  25.     structure, and since nested calls are FAR more likely than use as a
  26.     data structure, we just put up with the latter being wrong.  The same
  27.     applies to negation.
  28.  
  29.     Would anyone incorporating this in their Prolog system please credit
  30.     both me and David Warren;  he thought up the definitions, and my
  31.     implementation may owe more to subconscious memory of his than I like
  32.     to think.  At least this ought to put a stop to fraudulent claims to
  33.     having bagof, by replacing them with genuine claims.
  34.  
  35.     Thanks to Dave Bowen for pointing out an amazingly obscure bug: if
  36.     the Template was a variable and the Generator never bound it at all
  37.     you got a very strange answer!  Now fixed, at a price.
  38. */
  39.  
  40. /* **********************************************************************
  41.    SB-Prolog has the naming convention that library predicate names
  42.    begin with $.  I've taken the liberty of prepending $ to most of
  43.    O'Keefe's predicate names. -- SKDebray, Aug 1988.
  44. ********************************************************************** */
  45.  
  46. /* **********************************************************************
  47. :- public
  48.     findall/3,        %   Same effect as C&M p152
  49.     findall/4,        %   A variant I have found very useful
  50.     bag_of/3,        %   Like bagof (Dec-10 manual p52)
  51.     set_of/3.        %   Like setof (Dec-10 manual p51)
  52.  
  53. :- mode
  54.     bag_of(+,+,?),
  55.     $concordant_subset(+,+,-),
  56.     $concordant_subset(+,+,-,-),
  57.     $concordant_subset(+,+,+,+,-),
  58.     findall(+,+,?),
  59.     findall(+,+,+,?),
  60.     list_instances(+,-),
  61.     list_instances(+,+,-),
  62.     list_instances(+,+,+,-),
  63.     list_instances(+,+,+,+,-),
  64.     replace_key_variables(+,+,+),
  65.     save_instances(+,+),
  66.     set_of(+,+,?).
  67. ********************************************************************** */
  68.  
  69. $setof_export([$setof/3,$bagof/3,$findall/3,$sort/2,$keysort/2]).
  70.  
  71. /* $setof_use($meta,[$functor/3,$univ/2,$length/2]).
  72.    $setof_use($buff,[$alloc_perm/2,$alloc_heap/2,$trimbuff/3,$buff_code/4,
  73.         $symtype/2,
  74.         $substring/6,$subnumber/6,$subdelim/6,$conlength/2,
  75.         $pred_undefined/1, $hashval/3]).
  76.    $setof_use($bmeta,[$atom/1,$atomic/1,$integer/1,$number/1,$structure/1,
  77.     $functor0/2,$bldstr/3,$arg/3,$arity/2,$real/1,$float/1,_,_]).
  78. */
  79.  
  80. %   findall(Template, Generator, List)
  81. %   is a special case of bagof, where all free variables in the
  82. %   generator are taken to be existentially quantified.  It is
  83. %   described in Clocksin & Mellish on p152.  The code they give
  84. %   has a bug (which the Dec-10 bagof and setof predicates share)
  85. %   which this has not.
  86.  
  87. /* **********************************************************************
  88. % With SB-Prolog's current implementation of record/recorded, it's
  89. %  cheaper to use buff_code.  O'Keefe's original code was
  90.  
  91. findall(Template, Generator, List) :-
  92.     save_instances(-Template, Generator),
  93.     list_instances([], List).
  94.  
  95. %   findall(Template, Generator, SoFar, List) :-
  96. %    findall(Template, Generator, Solns),
  97. %    append(Solns, SoFar, List).
  98. %   But done more cheaply.
  99.  
  100. findall(Template, Generator, SoFar, List) :-
  101.     save_instances(-Template, Generator),
  102.     list_instances(SoFar, List).
  103. ********************************************************************** */
  104.  
  105. $findall(T,Call,Result) :-
  106.     $alloc_heap(5000,Buff),
  107.     $findall_1(T,Call,Result,Buff).
  108.  
  109. $findall_1(T,Call,Result,Buff) :-
  110.     $copyterm([],Buff,8,4,_), /* init result list to empty */
  111.     $buff_code(Buff,0,2 /*pn*/ ,8), /* init where to put next answer */
  112.     $buff_code(Buff,4,2 /*pn*/ ,12), /* init first free place */
  113.     call(Call),
  114.     $buff_code(Buff,0,5 /*gn*/ ,Place), /* get where to put answer */
  115.     $buff_code(Buff,4,5 /*gn*/ ,Start), /* get first free place */
  116.     $copyterm([T],Buff,Place,Start,End),
  117.     Tailloc is Start+4,    
  118.     $buff_code(Buff,0,2 /*pn*/ ,Tailloc), /* where to put next answer */
  119.     $buff_code(Buff,4,2 /*pn*/ ,End), /* next first free place */
  120.     fail.
  121.  
  122. $findall_1(_,_,Result,Buff) :-
  123.     $buff_code(Buff,4,5 /*gn*/ ,Length), /* Length =\= 12 fail if [] */
  124.     $trimbuff(Length,Buff,1),
  125.     $buff_code(Buff,8,18 /*vtb*/ ,Result).
  126.  
  127.  
  128. %   $setof(Template, Generator, Set)
  129. %   finds the Set of instances of the Template satisfying the Generator.
  130. %   The set is in ascending order (see compare/3 for a definition of
  131. %   this order) without duplicates, and is non-empty.  If there are
  132. %   no solutions, set_of fails.  set_of may succeed more than one way,
  133. %   binding free variables in the Generator to different values.  This
  134. %   predicate is defined on p51 of the Dec-10 Prolog manual.
  135.  
  136. $setof(Template, Filter, Set) :-
  137.     $bagof(Template, Filter, Bag),
  138.     $sort(Bag, Set).
  139.  
  140. %   $bagof(Template, Generator, Bag)
  141. %   finds all the instances of the Template produced by the Generator,
  142. %   and returns them in the Bag in they order in which they were found.
  143. %   If the Generator contains free variables which are not bound in the
  144. %   Template, it assumes that this is like any other Prolog question
  145. %   and that you want bindings for those variables.  (You can tell it
  146. %   not to bother by using existential quantifiers.)
  147. %   bag_of records three things under the key '.':
  148. %    the end-of-bag marker           -
  149. %    terms with no free variables   -Term
  150. %    terms with free variables   Key-Term
  151. %   The key '.' was chosen on the grounds that most people are unlikely
  152. %   to realise that you can use it at all, another good key might be ''.
  153. %   The original data base is restored after this call, so that set_of
  154. %   and bag_of can be nested.  If the Generator smashes the data base
  155. %   you are asking for trouble and will probably get it.
  156. %   The second clause is basically just findall, which of course works in
  157. %   the common case when there are no free variables.
  158.  
  159. $bagof(Template, Generator, Bag) :-
  160.     $free_variables(Generator, Template, [], Vars),
  161.     Vars \= [],
  162.     !,
  163.     Key =.. [.|Vars],
  164.     functor(Key, ., N),
  165. /* **********************************************************************
  166. % SB-Prolog version modified to use findall instead of record/recorded
  167. %    save_instances(Key-Template, Generator),
  168. %    list_instances(Key, N, [], OmniumGatherum),
  169. ********************************************************************** */
  170.         $findall(Key-Template,Generator,OmniumGatherum),
  171.     $keysort(OmniumGatherum, Gamut), !,
  172.     $concordant_subset(Gamut, Key, Answer),
  173.     Bag = Answer.
  174. $bagof(Template, Generator, Bag) :-
  175. /* **********************************************************************
  176. %    save_instances(-Template, Generator),
  177. %    list_instances([], Bag),
  178. ********************************************************************** */
  179.         $findall(Template,Generator,Bag).
  180.  
  181. /* **********************************************************************
  182. % In SB-Prolog, it's cheaper to use $buff_code than record/recorded, so
  183. % this code is never used and has been commented out.  O'Keefe's original
  184. % code is given below.  -- SKD, Aug 1988
  185.  
  186. %   save_instances(Template, Generator)
  187. %   enumerates all provable instances of the Generator and records the
  188. %   associated Template instances.  Neither argument ends up changed.
  189.  
  190. % save_instances(Template, Generator) :-
  191. %     recorda(., -, _),
  192. %     call(Generator),
  193. %     recorda(., Template, _),
  194. %     fail.
  195. % save_instances(_, _).
  196. % 
  197. %   list_instances(SoFar, Total)
  198. %   pulls all the -Template instances out of the data base until it
  199. %   hits the - marker, and puts them on the front of the accumulator
  200. %   SoFar.  This routine is used by findall/3-4 and by bag_of when
  201. %   the Generator has no free variables.
  202. % 
  203. % list_instances(SoFar, Total) :-
  204. %     recorded(., Term, Ref),
  205. %     erase(Ref), !,        %   must not backtrack
  206. %     list_instances(Term, SoFar, Total).
  207. % 
  208. % list_instances(-, SoFar, Total) :- !,
  209. %     Total = SoFar.        %   = delayed in case Total was bound
  210. % list_instances(-Template, SoFar, Total) :-
  211. %     list_instances([Template|SoFar], Total).
  212. % 
  213. %   list_instances(Key, NVars, BagIn, BagOut)
  214. %   pulls all the Key-Template instances out of the data base until
  215. %   it hits the - marker.  The Generator should not touch recordx(.,_,_).
  216. %   Note that asserting something into the data base and pulling it out
  217. %   again renames all the variables; to counteract this we use replace_
  218. %   key_variables to put the old variables back.  Fortunately if we
  219. %   bind X=Y, the newer variable will be bound to the older, and the
  220. %   original key variables are guaranteed to be older than the new ones.
  221. %   This replacement must be done @i<before> the keysort.
  222. % 
  223. % list_instances(Key, NVars, OldBag, NewBag) :-
  224. %     recorded(., Term, Ref),
  225. %     erase(Ref), !,        %  must not backtrack!
  226. %     list_instances(Term, Key, NVars, OldBag, NewBag).
  227. % 
  228. % 
  229. % list_instances(-, _, _, AnsBag, AnsBag) :- !.
  230. % list_instances(NewKey-Term, Key, NVars, OldBag, NewBag) :-
  231. %     replace_key_variables(NVars, Key, NewKey), !,
  232. %     list_instances(Key, NVars, [NewKey-Term|OldBag], NewBag).
  233. % 
  234. %   There is a bug in the compiled version of arg in Dec-10 Prolog,
  235. %   hence the rather strange code.  Only two calls on arg are needed
  236. %   in Dec-10 interpreted Prolog or C-Prolog.
  237. % 
  238. % replace_key_variables(0, _, _) :- !.
  239. % replace_key_variables(N, OldKey, NewKey) :-
  240. %     arg(N, NewKey, Arg),
  241. %     nonvar(Arg), !,
  242. %     M is N-1,
  243. %     replace_key_variables(M, OldKey, NewKey).
  244. % replace_key_variables(N, OldKey, NewKey) :-
  245. %     arg(N, OldKey, OldVar),
  246. %     arg(N, NewKey, OldVar),
  247. %     M is N-1,
  248. %     replace_key_variables(M, OldKey, NewKey).
  249. ********************************************************************** */
  250.  
  251. %   $concordant_subset([Key-Val list], Key, [Val list]).
  252. %   takes a list of Key-Val pairs which has been keysorted to bring
  253. %   all the identical keys together, and enumerates each different
  254. %   Key and the corresponding lists of values.
  255.  
  256. $concordant_subset([Key-Val|Rest], Clavis, Answer) :-
  257.     $concordant_subset(Rest, Key, List, More),
  258.     $concordant_subset(More, Key, [Val|List], Clavis, Answer).
  259.  
  260.  
  261. %   $concordant_subset(Rest, Key, List, More)
  262. %   strips off all the Key-Val pairs from the from of Rest,
  263. %   putting the Val elements into List, and returning the
  264. %   left-over pairs, if any, as More.
  265.  
  266. $concordant_subset([Key-Val|Rest], Clavis, [Val|List], More) :-
  267.     Key == Clavis,
  268.     !,
  269.     $concordant_subset(Rest, Clavis, List, More).
  270. $concordant_subset(More, _, [], More).
  271.  
  272.  
  273. %   $concordant_subset/5 tries the current subset, and if that
  274. %   doesn't work if backs up and tries the next subset.  The
  275. %   first clause is there to save a choice point when this is
  276. %   the last possible subset.
  277.  
  278. $concordant_subset([],   Key, Subset, Key, Subset) :- !.
  279. $concordant_subset(_,    Key, Subset, Key, Subset).
  280. $concordant_subset(More, _,   _,   Clavis, Answer) :-
  281.     $concordant_subset(More, Clavis, Answer).
  282.  
  283.  
  284. %   File   : NOT.PL
  285. %   Author : R.A.O'Keefe
  286. %   Updated: 17 November 1983
  287. %   Purpose: "suspicious" negation 
  288.  
  289. /*  This file defines a version of 'not' which checks that there are
  290.     no free variables in the goal it is given to "disprove".  Bound
  291.     variables introduced by the existential quantifier ^ or set/bag
  292.     dummy variables are accepted.  If any free variables are found, 
  293.     a message is printed on the terminal and a break level entered.
  294.  
  295.     It is intended purely as a debugging aid, though it shouldn't slow
  296.     interpreted code down much.  There are several other debugging
  297.     aids that you might want to use as well, particularly
  298.     unknown(_, trace)
  299.     which will detect calls to undefined predicates (as opposed to
  300.     predicates which have clauses that don't happen to match).
  301.  
  302.     The predicate $free_variables/4 defined in this files is also used
  303.     by the set_of/bag_of code.
  304.  
  305.     Note: in Dec-10 Prolog you should normally use "\+ Goal" instead
  306.     of "not(Goal)".  In C-Prolog you can use either, and would have to
  307.     do some surgery on pl/init to install this version of "not".  The
  308.     reason that I have called this predicate "not" is so that people
  309.     can choose whether to use the library predicate not/1 (in Invoca.Pl)
  310.     or this debugging one, not because I like the name.
  311. */
  312. /* **********************************************************************
  313. % :- public
  314. %     (not)/1.        %   new checking denial
  315. % 
  316. % :- mode
  317. %     $explicit_binding(+,+,-,-),
  318. %     $free_variables(+,+,+,-),
  319. %         $free_variables(+,+,+,+,-),
  320. %     $list_is_free_of(+,+),
  321. %     not(+),
  322. %     $term_is_free_of(+,+),
  323. %         $term_is_free_of(+,+,+).
  324. % 
  325. % :- op(900, fy, not).
  326. % 
  327. % 
  328. % not(Goal) :-
  329. %     $free_variables(Goal, [], [], Vars),
  330. %     Vars \== [], !,
  331. %     fwritef(user, '\n! free variables %t\n! in goal not(%t)\n',
  332. %         [Vars,Goal]),
  333. %     break,
  334. %     call(Goal),
  335. %     !, fail.
  336. % not(Goal) :-
  337. %     call(Goal),
  338. %     !, fail.
  339. % not(_).
  340. ********************************************************************** */
  341.  
  342. %   In order to handle variables properly, we have to find all the 
  343. %   universally quantified variables in the Generator.  All variables
  344. %   as yet unbound are universally quantified, unless
  345. %    a)  they occur in the template
  346. %    b)  they are bound by X^P, setof, or bagof
  347. %   $free_variables(Generator, Template, OldList, NewList)
  348. %   finds this set, using OldList as an accumulator.
  349.  
  350. $free_variables(Term, Bound, VarList, [Term|VarList]) :-
  351.     var(Term),
  352.     $term_is_free_of(Bound, Term),
  353.     $list_is_free_of(VarList, Term),
  354.     !.
  355. $free_variables(Term,_Bound, VarList, VarList) :-
  356.     var(Term),
  357.     !.
  358. $free_variables(Term, Bound, OldList, NewList) :-
  359.     $explicit_binding(Term, Bound, NewTerm, NewBound),
  360.     !,
  361.     $free_variables(NewTerm, NewBound, OldList, NewList).
  362. $free_variables(Term, Bound, OldList, NewList) :-
  363.     functor(Term, _, N),
  364.     $free_variables(N, Term, Bound, OldList, NewList).
  365.  
  366. $free_variables(0,_Term,_Bound, VarList, VarList) :- !.
  367. $free_variables(N, Term, Bound, OldList, NewList) :-
  368.     arg(N, Term, Argument),
  369.     $free_variables(Argument, Bound, OldList, MidList),
  370.     M is N-1, !,
  371.     $free_variables(M, Term, Bound, MidList, NewList).
  372.  
  373. %   $explicit_binding checks for goals known to existentially quantify
  374. %   one or more variables.  In particular \+ is quite common.
  375.  
  376. $explicit_binding(\+ _Goal,           Bound, fail,    Bound      ) :- !.
  377. $explicit_binding(not(_Goal),           Bound, fail,    Bound       ) :- !.
  378. $explicit_binding(Var^Goal,           Bound, Goal,    Bound+Var) :- !.
  379. $explicit_binding(setof(Var,Goal,Set),  Bound, Goal-Set, Bound+Var) :- !.
  380. $explicit_binding(bagof(Var,Goal,Bag),  Bound, Goal-Bag, Bound+Var) :- !.
  381. $explicit_binding(set_of(Var,Goal,Set), Bound, Goal-Set, Bound+Var) :- !.
  382. $explicit_binding(bag_of(Var,Goal,Bag), Bound, Goal-Bag, Bound+Var) :- !.
  383.  
  384.  
  385. /* **********************************************************************
  386.    Some recoding to make the code more efficient.  O'Keefe's original
  387.    code is:
  388.  
  389. % $term_is_free_of(Term, Var) :-
  390. %     var(Term), !,
  391. %     Term \== Var.
  392. % $term_is_free_of(Term, Var) :-
  393. %     functor(Term, _, N),
  394. %     $term_is_free_of(N, Term, Var).
  395. % 
  396. % $term_is_free_of(0,_Term,_Var) :- !.
  397. % $term_is_free_of(N, Term, Var) :-
  398. %     arg(N, Term, Argument),
  399. %     $term_is_free_of(Argument, Var),
  400. %     M is N-1, !,
  401. %     $term_is_free_of(M, Term, Var).
  402. ********************************************************************** */
  403.  
  404. $term_is_free_of(Term, Var) :-
  405.     var(Term) ->
  406.          Term \== Var ;
  407.          ($arity(Term, N),
  408.           $term_is_free_of(N, Term, Var)
  409.          ).
  410.  
  411. $term_is_free_of(N, Term, Var) :-
  412.     N =:= 0 ->
  413.          true ;
  414.          (arg(N, Term, Argument),
  415.           $term_is_free_of(Argument, Var),
  416.           M is N-1,
  417.           $term_is_free_of(M, Term, Var)
  418.          ).
  419.  
  420.  
  421. $list_is_free_of([Head|Tail], Var) :-
  422.     Head \== Var,
  423.     !,
  424.     $list_is_free_of(Tail, Var).
  425. $list_is_free_of([], _).
  426.  
  427. /*======================================================================*/
  428.  
  429. /* This routine copies a term into a buffer. It is passed:
  430.     Term: the term to copy,
  431.     Buffer: the buffer to copy it into,
  432.     Worddisp: the word of the buffer in which to put the copy (or
  433.         a pointer to the copy.)
  434.     Start: the disp of the next free location in the buffer, before the 
  435.         copy is done.
  436.     End: (returned) the location of the first free location after the
  437.         copying.
  438.  
  439.     Variables are copied into the buffer and the copied variables are
  440.     pointed into the buffer and trailed. Thus later binding of these 
  441.     `outside' variables will cause the copied variables to be changed,
  442.     too. If, however, the $copyterm call is failed over, the variables
  443.     in the buffer will be ``disconnected'' from the outer variables.
  444.  
  445.     Copyterm is a prime candidate for moving down into the simulator as
  446.     a builtin written in C.
  447. */
  448.  
  449.  
  450. $copyterm(Term,Buff,Worddisp,Start,Start) :-
  451.     var(Term),!,$buff_code(Buff,Worddisp,17 /*pvar*/ ,Term).
  452.  
  453. $copyterm(Term,Buff,Worddisp,Start,Start) :-
  454.     number(Term),!,$buff_code(Buff,Worddisp,14 /*ptv*/ ,Term).
  455.  
  456. $copyterm(Term,Buff,Worddisp,Start,Start) :-
  457.     $atom(Term),!,$buff_code(Buff,Worddisp,14 /*ptv*/ ,Term).
  458.  
  459. $copyterm(Term,Buff,Worddisp,Start,End) :-
  460.     Term=[_|_],!,
  461.     $buff_code(Buff,Worddisp,16 /*ptl*/ ,Start), /* ptr to list rec */
  462.     Newstart is Start+8, /* reserve rec space */
  463.     $copyargs(Term,1,2,Buff,Start,Newstart,End).
  464.     
  465. $copyterm(Term,Buff,Worddisp,Start,End) :-
  466.     $structure(Term),!,
  467.     $buff_code(Buff,Worddisp,15 /*ptp*/ ,Start), /* ptr to str rec */
  468.     $buff_code(Buff,Start,0 /*ppsc*/ ,Term), /* rec psc ptr */
  469.     Argsloc is Start+4,
  470.     $arity(Term,Arity),Newstart is Argsloc+4*Arity, /* reserve rec space*/
  471.     $copyargs(Term,1,Arity,Buff,Argsloc,Newstart,End).
  472.     
  473. $copyargs(Term,Argno,Maxargs,Buff,Argloc,Start,End) :- 
  474.     Argno > Maxargs,
  475.      Start=End;
  476.     Argno =< Maxargs,
  477.      arg(Argno,Term,Arg),$copyterm(Arg,Buff,Argloc,Start,Mid),
  478.      Nargno is Argno+1, Nargloc is Argloc+4,
  479.      $copyargs(Term,Nargno,Maxargs,Buff,Nargloc,Mid,End).
  480.  
  481.  
  482. /* Sorting by bisecting and merging. */
  483.  
  484. $sort(L,R) :- $length(L,N), $sort(N,L,_,R1), R=R1.
  485.  
  486. $sort(N,U,L,R) :-
  487.     N > 2 ->
  488.         (N1 is N >> 1, N2 is N-N1,
  489.          $sort(N1,U,L2,R1),
  490.          $sort(N2,L2,L,R2),
  491.          $merge(R1,R2,R)
  492.         ) ;
  493.         (N =:= 2 ->
  494.             (U = [X1|L1],
  495.              L1 = [X2|L],
  496.              $compare(Delta,X1,X2),
  497.              (Delta ?= (<) -> R = [X1,X2] ;
  498.               Delta ?= (>) -> R = [X2,X1] ;
  499.                         R = [X2]
  500.              )
  501.             ) ;
  502.             (N =:= 1 ->
  503.                 (U = [X|L], R = [X]) ;
  504.                 (U = L, R = [])        /* N == 0 */
  505.             )
  506.          ).
  507.  
  508. $merge([],R,R) :- !.
  509. $merge(R,[],R) :- !.
  510. $merge(R1,R2,[X|R]) :-
  511.    R1 = [X1|R1a], R2 = [X2|R2a],
  512.    $compare(Delta,X1,X2),
  513.    (Delta ?= (<) ->
  514.        (X = X1, $merge(R1a,R2,R)) ;
  515.        (Delta ?= (>) ->
  516.             (X = X2, $merge(R1,R2a,R)) ;
  517.         (X = X1, $merge(R1a,R2a,R))
  518.        )
  519.    ).
  520.  
  521. /* Sorting on keys by bisecting and merging. */
  522.  
  523. $keysort(L,R) :- $length(L,N), $keysort(N,L,_,R1), R=R1.
  524.  
  525. $keysort(N,U,L,R) :-
  526.     N > 2 ->
  527.          (N1 is N >> 1, N2 is N-N1,
  528.           $keysort(N1,U,L2,R1),
  529.              $keysort(N2,L2,L,R2),
  530.              $keymerge(R1,R2,R)
  531.          ) ;
  532.          (N =:= 2 ->
  533.               (U = [X1|L1],
  534.            L1 = [X2|L],
  535.            $compare_keys(Delta,X1,X2),
  536.            (Delta ?= (>) -> R = [X2,X1] ; R = [X1,X2])
  537.           ) ;
  538.           (N =:= 1 ->
  539.               (U = [X|L], R = [X]) ;
  540.             (U = L, R = [])        /* N == 0 */
  541.           )
  542.          ).
  543.  
  544. $keymerge([],R,R) :- !.
  545. $keymerge(R,[],R) :- !.
  546. $keymerge(R1,R2,[X|R]) :-
  547.    R1 = [X1|R1a], R2 = [X2|R2a],
  548.    $compare_keys(Delta,X1,X2),
  549.    (Delta ?= (>) ->
  550.         (X = X2, $keymerge(R1,R2a,R)) ;
  551.     (X = X1, $keymerge(R1a,R2,R))
  552.    ).
  553.  
  554. $compare_keys(Delta,K1-X1,K2-X2) :- $compare(Delta,K1,K2).
  555.  
  556. /*======================================================================*/
  557.  
  558. X^P :- call(P).
  559.  
  560. /*======================================================================*/
  561.  
  562. /* ------------------------------ $setof.P ------------------------------ */
  563.